home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / GRAPHICS.SWG / 0048_Gif Source 1.pas < prev    next >
Pascal/Delphi Source File  |  1994-01-27  |  13KB  |  457 lines
  1. {
  2. > Can you post the gif source and any other graphic source for doing this
  3.  
  4. Here is gif format (it doesn't get to full 768·1024·256)
  5. or even less, but it is ok.
  6. }
  7.  
  8. {$R-}{$S-}{$B-}
  9. program GIF4TP;
  10.  
  11. uses
  12.   crt, GRAPH;
  13.  
  14. const
  15.   ProgramName = 'TP4GIF';
  16.   ProgramRevision = '2';
  17.  
  18. type
  19.   BufferArray = array[0..63999] of byte;
  20.   BufferPointer = ^BufferArray;
  21.  
  22. var
  23.   GifFile : file of BufferArray;
  24.   InputFileName : string;
  25.   RawBytes : BufferPointer;   { The heap array to hold it, raw    }
  26.   Buffer : BufferPointer;     { The Buffer data stream, unblocked }
  27.   Buffer2 : BufferPointer;    { More Buffer data stream if needed }
  28.   Byteoffset,                 { Computed byte position in Buffer array }
  29.   BitIndex                    { Bit offset of next code in Buffer array }
  30.    : longint;
  31.  
  32.   Width,      {Read from GIF header, image width}
  33.   Height,     { ditto, image height}
  34.   LeftOfs,    { ditto, image offset from left}
  35.   TopOfs,     { ditto, image offset from top}
  36.   RWidth,     { ditto, Buffer width}
  37.   RHeight,    { ditto, Buffer height}
  38.   ClearCode,  {GIF clear code}
  39.   EOFCode,    {GIF end-of-information code}
  40.   OutCount,   {Decompressor output 'stack count'}
  41.   MaxCode,    {Decompressor limiting value for current code size}
  42.   CurCode,    {Decompressor variable}
  43.   OldCode,    {Decompressor variable}
  44.   InCode,     {Decompressor variable}
  45.   FirstFree,  {First free code, generated per GIF spec}
  46.   FreeCode,   {Decompressor, next free slot in hash table}
  47.   RawIndex,     {Array pointers used during file read}
  48.   BufferPtr,
  49.   XC,YC,      {Screen X and Y coords of current pixel}
  50.   ReadMask,   {Code AND mask for current code size}
  51.   I           {Loop counter, what else?}
  52.   :word;
  53.  
  54.   Interlace,  {true if interlaced image}
  55.   AnotherBuffer, {true if file > 64000 bytes}
  56.   ColorMap    {true if colormap present}
  57.   : boolean;
  58.  
  59.   ch : char;
  60.   a,              {Utility}
  61.   Resolution,     {Resolution, read from GIF header}
  62.   BitsPerPixel,   {Bits per pixel, read from GIF header}
  63.   Background,     {Background color, read from GIF header}
  64.   ColorMapSize,   {Length of color map, from GIF header}
  65.   CodeSize,       {Code size, read from GIF header}
  66.   InitCodeSize,   {Starting code size, used during Clear}
  67.   FinChar,        {Decompressor variable}
  68.   Pass,           {Used by video output if interlaced pic}
  69.   BitMask,        {AND mask for data size}
  70.   R,G,B
  71.   :byte;
  72.  
  73.     {The hash table used by the decompressor}
  74.   Prefix: array[0..4095] of word;
  75.   Suffix: array[0..4095] of byte;
  76.  
  77.     {An output array used by the decompressor}
  78.   PixelValue : array[0..1024] of byte;
  79.  
  80.     {The color map, read from the GIF header}
  81.   Red,Green,Blue: array [0..255] of byte;
  82.   MyPalette : PaletteType;
  83.  
  84.   TempString : String;
  85.  
  86. Const
  87.  MaxCodes: Array [0..9] of Word = (4,8,16,$20,$40,$80,$100,$200,$400,$800);
  88.  CodeMask:Array [1..4] of byte= (1,3,7,15);
  89.  PowersOf2: Array [0..8] of word=(1,2,4,8,16,32,64,128,256);
  90.  Masks: Array [0..9] of integer = (7,15,$1f,$3f,$7f,$ff,$1ff,$3ff,$7ff,$fff);
  91.  BufferSize : Word = 64000;
  92.  
  93. function NewExtension(FileName,Extension : string) : string;
  94. {
  95. Places a new extension on to the file name.
  96. }
  97. var
  98.   I : integer;
  99. begin
  100.   if (Extension[1] = '.') then delete(Extension,1,1);
  101.   delete(Extension,4,251);
  102.   I := pos('.',FileName);
  103.   if (I = 0) then
  104.   begin
  105.     while (length(FileName) > 0) and (FileName[length(FileName)] = ' ')
  106.       do delete(FileName,length(FileName),1);
  107.     NewExtension := FileName + '.' + Extension;
  108.   end else begin
  109.     delete(FileName,I + 1,254 - I);
  110.     NewExtension := FileName + Extension;
  111.   end;
  112. end; { NewExtension }
  113.  
  114. function Min(I,J : longint) : longint;
  115. begin
  116.   if (I < J) then Min := I else Min := J;
  117. end; { Min }
  118.  
  119. procedure AllocMem(var P : BufferPointer);
  120. var
  121.   ASize : longint;
  122. begin
  123.   ASize := MaxAvail;
  124.   if (ASize < BufferSize) then begin
  125.     Textmode(15);
  126.     writeln('Insufficient memory available!');
  127.     halt;
  128.   end else getmem(P,BufferSize);
  129. end; { AllocMem }
  130.  
  131. function Getbyte : byte;
  132. begin
  133.   if (RawIndex >= BufferSize) then exit;
  134.   Getbyte := RawBytes^[RawIndex];
  135.   inc(RawIndex);
  136. end;
  137.  
  138. function Getword : word;
  139. var
  140.   W : word;
  141. begin
  142.   if (succ(RawIndex) >= BufferSize) then exit;
  143.   move(RawBytes^[RawIndex],W,2);
  144.   inc(RawIndex,2);
  145.   Getword := W;
  146. end; { GetWord }
  147.  
  148. procedure ReadBuffer;
  149. var
  150.   BlockLength : byte;
  151.   I,IOR : integer;
  152. begin
  153.   BufferPtr := 0;
  154.   Repeat
  155.     BlockLength := Getbyte;
  156.     For I := 0 to Blocklength-1 do
  157.     begin
  158.       if RawIndex = BufferSize then
  159.       begin
  160.         {$I-}
  161.         Read (GIFFile,RawBytes^);
  162.         {$I+}
  163.         IOR := IOResult;
  164.         RawIndex := 0;
  165.       end;
  166.       if not AnotherBuffer
  167.         then Buffer^[BufferPtr] := Getbyte
  168.         else Buffer2^[BufferPtr] := Getbyte;
  169.       BufferPtr := Succ (BufferPtr);
  170.       if BufferPtr=BufferSize then begin
  171.         AnotherBuffer := true;
  172.         BufferPtr := 0;
  173.         AllocMem (Buffer2);
  174.       end;
  175.     end;
  176.   Until Blocklength=0;
  177. end; { ReadBuffer }
  178.  
  179. procedure InitEGA;
  180. var
  181.   Driver,Mode : integer;
  182. begin
  183.   DetectGraph(Driver,Mode);
  184.   InitGraph(Driver,Mode,'e:\bp\bgi');
  185.   SetAllPalette(MyPalette);
  186.   if (Background <> 0) then begin
  187.     SetFillStyle(SolidFill,Background);
  188.     bar(0,0,Width,Height);
  189.   end;
  190. end; { InitEGA }
  191.  
  192. procedure DetColor(var PValue : byte; MapValue : Byte);
  193. {
  194. Determine the palette value corresponding to the GIF colormap intensity
  195. value.
  196. }
  197. var
  198.   Local : byte;
  199. begin
  200.   PValue := MapValue div 64;
  201.   if (PValue = 1)
  202.     then PValue := 2
  203.     else if (PValue = 2)
  204.       then PValue := 1;
  205. end; { DetColor }
  206.  
  207. procedure Init;
  208. var
  209.   I : integer;
  210. begin
  211.   XC := 0;          {X and Y screen coords back to home}
  212.   YC := 0;
  213.   Pass := 0;        {Interlace pass counter back to 0}
  214.   BitIndex := 0;   {Point to the start of the Buffer data stream}
  215.   RawIndex := 0;      {Mock file read pointer back to 0}
  216.   AnotherBuffer := false;    {Over 64000 flag off}
  217.   AllocMem(Buffer);
  218.   AllocMem(RawBytes);
  219.   InputFileName := NewExtension(InputFileName,'GIF');
  220.   {$I-}
  221.   Assign(giffile,InputFileName);
  222.   Reset(giffile);
  223.   I := IOResult;
  224.   if (I <> 0) then begin
  225.     textmode(15);
  226.     writeln('Error opening file ',InputFileName,'. Press any key ');
  227.     readln;
  228.     halt;
  229.   end;
  230.   read(GIFFile,RawBytes^);
  231.   I := IOResult;
  232. {$I+}
  233. end; { Init }
  234.  
  235. procedure ReadGifHeader;
  236. var
  237.   I : integer;
  238. begin
  239.   TempString := '';
  240.   for I := 1 to 6 do TempString := TempString + chr(Getbyte);
  241.   if (TempString <> 'GIF87a') then begin
  242.     textmode(15);
  243.     writeln('Not a GIF file, or header read error. Press enter.');
  244.     readln;
  245.     halt;
  246.   end;
  247. {
  248. Get variables from the GIF screen descriptor
  249. }
  250.   RWidth := Getword;         {The Buffer width and height}
  251.   RHeight := Getword;
  252. {
  253. Get the packed byte immediately following and decode it
  254. }
  255.   B := Getbyte;
  256.   Colormap := (B and $80 = $80);
  257.   Resolution := B and $70 shr 5 + 1;
  258.   BitsPerPixel := B and 7 + 1;
  259.   ColorMapSize := 1 shl BitsPerPixel;
  260.   BitMask := CodeMask[BitsPerPixel];
  261.   Background := Getbyte;
  262.   B := Getbyte;         {Skip byte of 0's}
  263. {
  264. Compute size of colormap, and read in the global one if there. Compute
  265. values to be used when we set up the EGA palette
  266. }
  267.   MyPalette.Size := Min(ColorMapSize,16);
  268.   if Colormap then begin
  269.     for I := 0 to pred(ColorMapSize) do begin
  270.       Red[I] := Getbyte;
  271.       Green[I] := Getbyte;
  272.       Blue[I] := Getbyte;
  273.       DetColor(R,Red[I]);
  274.       DetColor(G,Green [I]);
  275.       DetColor(B,Blue [I]);
  276.       MyPalette.Colors[I] := B and 1 +
  277.                     ( 2 * (G and 1)) + ( 4 * (R and 1)) + (8 * (B div 2)) +
  278.                     (16 * (G div 2)) + (32 * (R div 2));
  279.     end;
  280.   end;
  281. {
  282. Now read in values from the image descriptor
  283. }
  284.   B := Getbyte;  {skip image seperator}
  285.   Leftofs := Getword;
  286.   Topofs := Getword;
  287.   Width := Getword;
  288.   Height := Getword;
  289.   A := Getbyte;
  290.   Interlace := (A and $40 = $40);
  291.   if Interlace then begin
  292.     textmode(15);
  293.     writeln(ProgramName,' is unable to display interlaced GIF pictures.');
  294.     halt;
  295.   end;
  296. end; { ReadGifHeader }
  297.  
  298. procedure PrepDecompressor;
  299. begin
  300.   Codesize := Getbyte;
  301.   ClearCode := PowersOf2[Codesize];
  302.   EOFCode := ClearCode + 1;
  303.   FirstFree := ClearCode + 2;
  304.   FreeCode := FirstFree;
  305.   inc(Codesize); { since zero means one... }
  306.   InitCodeSize := Codesize;
  307.   Maxcode := Maxcodes[Codesize - 2];
  308.   ReadMask := Masks[Codesize - 3];
  309. end; { PrepDecompressor }
  310.  
  311. procedure DisplayGIF;
  312. {
  313. Decompress and display the GIF data.
  314. }
  315. var
  316.   Code : word;
  317.  
  318.   procedure DoClear;
  319.   begin
  320.     CodeSize := InitCodeSize;
  321.     MaxCode := MaxCodes[CodeSize-2];
  322.     FreeCode := FirstFree;
  323.     ReadMask := Masks[CodeSize-3];
  324.   end; { DoClear }
  325.  
  326.   procedure ReadCode;
  327.   var
  328.     Raw : longint;
  329.   begin
  330.     if (CodeSize >= 8) then begin
  331.       move(Buffer^[BitIndex shr 3],Raw,3);
  332.       Code := (Raw shr (BitIndex mod 8)) and ReadMask;
  333.     end else begin
  334.       move(Buffer^[BitIndex shr 3],Code,2);
  335.       Code := (Code shr (BitIndex mod 8)) and ReadMask;
  336.     end;
  337.     if AnotherBuffer then begin
  338.       ByteOffset := BitIndex shr 3;
  339.       if (ByteOffset >= 63000) then begin
  340.         move(Buffer^[Byteoffset],Buffer^[0],BufferSize-Byteoffset);
  341.         move(Buffer2^[0],Buffer^[BufferSize-Byteoffset],63000);
  342.         BitIndex := BitIndex mod 8;
  343.         FreeMem(Buffer2,BufferSize);
  344.       end;
  345.     end;
  346.     BitIndex := BitIndex + CodeSize;
  347.   end; { ReadCode }
  348.  
  349.   procedure OutputPixel(Color : byte);
  350.   begin
  351.     putpixel(XC,YC,Color); { about 3x faster than using the DOS interrupt! }
  352.     inc(XC);
  353.     if (XC = Width) then begin
  354.       XC := 0;
  355.       inc(YC);
  356.       if (YC mod 10 = 0) and keypressed and (readkey = #27) then begin
  357.         textmode(15);  { let the user bail out }
  358.         halt;
  359.       end;
  360.     end;
  361.   end; { OutputPixel }
  362.  
  363.  
  364.  
  365. begin { DisplayGIF }
  366.   CurCode := 0; { not initted anywhere else... don't know why }
  367.   OldCode := 0; { not initted anywhere else... don't know why }
  368.   FinChar := 0; { not initted anywhere else... don't know why }
  369.   OutCount := 0;
  370.   DoClear;      { not initted anywhere else... don't know why }
  371.   repeat
  372.     ReadCode;
  373.     if (Code <> EOFCode) then begin
  374.       if (Code = ClearCode) then begin { restart decompressor }
  375.         DoClear;
  376.         ReadCode;
  377.         CurCode := Code;
  378.         OldCode := Code;
  379.         FinChar := Code and BitMask;
  380.         OutputPixel(FinChar);
  381.       end else begin        { must be data: save same as CurCode and InCode }
  382.         CurCode := Code;
  383.         InCode := Code;
  384. { if >= FreeCode, not in hash table yet; repeat the last character decoded }
  385.         if (Code >= FreeCode) then begin
  386.           CurCode := OldCode;
  387.           PixelValue[OutCount] := FinChar;
  388.           inc(OutCount);
  389.         end;
  390. {
  391. Unless this code is raw data, pursue the chain pointed to by CurCode
  392. through the hash table to its end; each code in the chain puts its
  393. associated output code on the output queue.
  394. }
  395.         if (CurCode > BitMask) then repeat
  396.           PixelValue[OutCount] := Suffix[CurCode];
  397.           inc(OutCount);
  398.           CurCode := Prefix[CurCode];
  399.         until (CurCode <= BitMask);
  400. {
  401. The last code in the chain is raw data.
  402. }
  403.         FinChar := CurCode and BitMask;
  404.         PixelValue[OutCount] := FinChar;
  405.         inc(OutCount);
  406. {
  407. Output the pixels. They're stacked Last In First Out.
  408. }
  409.         for I := pred(OutCount) downto 0 do OutputPixel(PixelValue[I]);
  410.         OutCount := 0;
  411. {
  412. Build the hash table on-the-fly.
  413. }
  414.         Prefix[FreeCode] := OldCode;
  415.         Suffix[FreeCode] := FinChar;
  416.         OldCode := InCode;
  417. {
  418. Point to the next slot in the table. If we exceed the current MaxCode
  419. value, increment the code size unless it's already 12. if it is, do
  420. nothing: the next code decompressed better be CLEAR
  421. }
  422.         inc(FreeCode);
  423.         if (FreeCode >= MaxCode) then begin
  424.           if (CodeSize < 12) then begin
  425.             inc(CodeSize);
  426.             MaxCode := MaxCode * 2;
  427.             ReadMask := Masks[CodeSize - 3];
  428.           end;
  429.         end;
  430.       end; {not Clear}
  431.     end; {not EOFCode}
  432.   until (Code = EOFCode);
  433. end; { DisplayGIF }
  434.  
  435. begin { TP4GIF }
  436.   writeln(ProgramName,' Rev ',ProgramRevision);
  437.   if (paramcount > 0)
  438.     then TempString := paramstr(1)
  439.   else begin
  440.     write(' > ');
  441.     readln(TempString);
  442.   end;
  443.   InputFileName := TempString;
  444.   Init;
  445.   ReadGifHeader;
  446.   PrepDecompressor;
  447.   ReadBuffer;
  448.   FreeMem(RawBytes,BufferSize);
  449.   InitEGA;
  450.   DisplayGIF;
  451.   SetAllPalette(MyPalette);
  452.   close(GifFile);
  453.   Ch := readkey;
  454.   textmode(15);
  455.   freemem(Buffer,BufferSize);        { totally pointless, but it's good form }
  456. end.
  457.